Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue44/alfresco/AAHuffmn.pas

Pascal/Delphi Source File | 1999-02-28 | 23.2 KB | 739 lines

{*********************************************************}
{* AAHuffmn                                              *}
{* Copyright (c) Julian M Bucknall 1999                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Huffman compression and decompression                 *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

unit AAHuffmn;

interface

uses
  SysUtils, Classes;

{$IFOPT D+}
{$DEFINE InDebugMode}
{$ENDIF}

procedure HuffmanCompress(aInStream, aOutStream : TStream);
procedure HuffmanDecompress(aInStream, aOutStream : TStream);

implementation

const
  vaByte    = 0;   {value is a byte: 0..255}
  vaWord    = 1;   {value is a word: 255..65535}
  vaLongint = 2;   {value is a longint: all other values}

const
  Bit : array [0..7] of byte =  {bit masks}
        ($01, $02, $04, $08, $10, $20, $40, $80);

type
  PHuffmanNode = ^THuffmanNode;
  THuffmanNode = packed record
    hnCount    : longint;
    hnLeftInx  : longint;
    hnRightInx : longint;
  end;

  PHuffmanTree = ^THuffmanTree;
  THuffmanTree = array [0..510] of THuffmanNode;

type
  THuffmanCodeStr = string[255];

  PHuffmanCode = ^THuffmanCode;
  THuffmanCode = packed record
    hcBitCount : longint;
    hcCode     : array [0..31] of byte;
  end;

  PHuffmanCodes = ^THuffmanCodes;
  THuffmanCodes = array [0..255] of THuffmanCode;


{===THuffmanPriorityQueue=============================================}
type
  longint = integer;

  THuffmanPriorityQueue = class
    {-A priority queue for Huffman compression}
    private
      pqList : TList;
      pqTree : PHuffmanTree;
    protected
      function pqGetCount : integer;

      procedure pqBubbleUp(aFromInx : integer; aItem : longint);
      procedure pqTrickleDown(aFromInx : integer; aItem : longint);
    public
      constructor Create(aHTree : PHuffmanTree);
        {-Create the priority queue}
      destructor Destroy; override;
        {-Dispose of the priority queue}

      procedure Add(aItem : longint);
        {-Add an item (ie, Huffman tree index) to the priority queue}
      function Remove : longint;
        {-Remove and return the item (ie, Huffman tree index) with the
          smallest count}

      property Count : integer read pqGetCount;
        {-Count of items in the queue}

      property List : TList read pqList;
  end;
{--------}
constructor THuffmanPriorityQueue.Create(aHTree : PHuffmanTree);
begin
  inherited Create;
  {create the queue's array; we know it'll be at most 256 elements}
  pqList := TList.Create;
  pqList.Capacity := 256;
  {remember the Huffman tree we're using}
  pqTree := aHTree;
end;
{--------}
destructor THuffmanPriorityQueue.Destroy;
begin
  pqList.Free;
  inherited Destroy;
end;
{--------}
procedure THuffmanPriorityQueue.Add(aItem : longint);
begin
  {add extra space at the end of the queue}
  pqList.Count := pqList.Count + 1;
  {now bubble the item up as far as it will go}
  pqBubbleUp(pred(pqList.Count), aItem);
end;
{--------}
procedure THuffmanPriorityQueue.pqBubbleUp(aFromInx : integer;
                                           aItem    : longint);
var
  ParentInx : integer;
  ItemCount : longint;
begin
  {while the item under consideration is smaller than its parent, swap
   it with its parent and continue from its new position}
  {Note: the parent for the child at index N is at (N-1) div 2}
  ItemCount := pqTree^[aItem].hnCount;
  ParentInx := (aFromInx - 1) div 2;
  {while our item has a parent, and it's greater than the parent...}
  while (aFromInx > 0) and
        (ItemCount <
           pqTree^[longint(pqList[ParentInx])].hnCount) do begin
    {move our parent down the tree}
    pqList[aFromInx] := pqList[ParentInx];
    aFromInx := ParentInx;
    ParentInx := (aFromInx - 1) div 2;
  end;
  {store our item in the correct place}
  pqList[aFromInx] := pointer(aItem);
end;
{--------}
function THuffmanPriorityQueue.pqGetCount : integer;
begin
  Result := pqList.Count;
end;
{--------}
procedure THuffmanPriorityQueue.pqTrickleDown(aFromInx : integer;
                                              aItem    : longint);
var
  ChildInx  : integer;
  ListCount : integer;
  ItemCount : longint;
begin
  {while the item under consideration is greater than one of its
   children, swap it with the smaller child and continue from its new
   position}
  {Note: the children for the parent at index N are at (2N+1) and
         2N+2}
  ItemCount := pqTree^[aItem].hnCount;
  ListCount := pqList.Count;
  {calculate the left child index}
  ChildInx := succ(aFromInx * 2);
  {while there is at least a left child...}
  while (ChildInx < ListCount) do begin
    {if there is a right child, calculate the index of the smaller
     child}
    if (succ(ChildInx) < ListCount) and
       (pqTree^[longint(pqList[ChildInx])].hnCount >
          pqTree^[longint(pqList[succ(ChildInx)])].hnCount) then
      inc(ChildInx);
    {if our item is less or equal to the smaller child, we're done}
    if (ItemCount <= pqTree^[longint(pqList[ChildInx])].hnCount) then
      Break;
    {otherwise move the smaller child up the tree, and move our item
     down the tree and repeat}
    pqList[aFromInx] := pqList[ChildInx];
    aFromInx := ChildInx;
    ChildInx := succ(aFromInx * 2);
  end;
  {store our item in the correct place}
  pqList[aFromInx] := pointer(aItem);
end;
{--------}
function THuffmanPriorityQueue.Remove : longint;
begin
  {return the item at the root}
  Result := longint(pqList[0]);
  {replace the root with the child at the lowest, rightmost position,
   and shrink the list}
  pqList[0] := pqList.Last;
  pqList.Count := pqList.Count - 1;
  {now trickle down the root item as far as it will go}
  if (pqList.Count > 0) then
    pqTrickleDown(0, longint(pqList[0]));
end;
{====================================================================}


{===Exception handling===============================================}
procedure RaiseWriteError;
begin
  raise Exception.Create('Cannot write to Huffman compressed stream');
end;
{--------}
procedure RaiseReadError;
begin
  raise Exception.Create('Expecting more data in Huffman compressed stream, but none left');
end;
{--------}
procedure RaiseReadCorruptError;
begin
  raise Exception.Create('Huffman compressed stream contains corrupted data');
end;
{====================================================================}


{===Helper routines==================================================}
procedure WriteBits(const aHCode    : THuffmanCode;
                          aStream   : TStream;
                      var aCollByte : byte;
                      var aCollCount: integer);
var
  ByteNum : integer;
  BitNum  : integer;
  i       : integer;
  TempCollByte  : byte;
  TempCollCount : integer;
begin
  {make temporary copies of the var parameters for speed}
  TempCollByte := aCollByte;
  TempCollCount := aCollCount;
  {start off with the correct mask}
  ByteNum := 0;
  BitNum := 7;
  {for all bits...}
  for i := 0 to pred(aHCode.hcBitCount) do begin
    {shift collector byte left by one (sets low bit to zero)}
    TempCollByte := TempCollByte shl 1;
    {if the current bit is set, set low bit of the collector byte}
    if (aHCode.hcCode[ByteNum] and Bit[BitNum]) <> 0 then
      TempCollByte := TempCollByte or 1;
    {we've added one more bit}
    inc(TempCollCount);
    {if the collector byte is full, write it out, reset bit count}
    if (TempCollCount = 8) then begin
      aStream.Write(TempCollByte, 1);
      TempCollCount := 0;
    end;
    {get next bit}
    if (BitNum = 0) then begin
      BitNum := 7;
      inc(ByteNum);
    end
    else
      dec(BitNum);
  end;
  {set new values of var parameters}
  aCollByte := TempCollByte;
  aCollCount := TempCollCount;
end;
{--------}
function ReadChar(aStream : TStream) : char;
{-read a character from the stream}
var
  BytesRead : integer;
begin
  BytesRead := aStream.Read(Result, sizeof(char));
  if (BytesRead <> sizeof(char)) then
    RaiseReadError;
end;
{--------}
function ReadValue(aStream : TStream) : longint;
{-read an integer value from the stream}
var
  BytesRead : integer;
  ValueType : byte;
begin
  Result := 0;
  BytesRead := aStream.Read(ValueType, sizeof(ValueType));
  if (BytesRead <> sizeof(ValueType)) then
    RaiseReadError;
  case ValueType of
    vaByte :
      begin
        BytesRead := aStream.Read(Result, sizeof(byte));
        if (BytesRead <> sizeof(byte)) then
          RaiseReadError;
      end;
    vaWord :
      begin
        BytesRead := aStream.Read(Result, sizeof(word));
        if (BytesRead <> sizeof(word)) then
          RaiseReadError;
      end;
    vaLongint :
      begin
        BytesRead := aStream.Read(Result, sizeof(longint));
        if (BytesRead <> sizeof(longint)) then
          RaiseReadError;
      end;
  else {it's an unknown value type}
    RaiseReadCorruptError;
  end;{case}
end;
{--------}
procedure WriteChar(aStream : TStream; aChar : char);
{-write a character to the stream}
var
  BytesWrit : integer;
begin
  BytesWrit := aStream.Write(aChar, sizeof(char));
  if (BytesWrit <> sizeof(char)) then
    RaiseWriteError;
end;
{--------}
procedure WriteValue(aStream : TStream; aValue : longint);
{-write an integer value to the stream}
var
  BytesWrit : integer;
  ValueType : byte;
begin
  {if the value is between 0 and 255 write a byte to the stream}
  if (0 <= aValue) and (aValue < 256) then begin
    ValueType := vaByte;
    BytesWrit := aStream.Write(ValueType, sizeof(ValueType));
    if (BytesWrit <> sizeof(ValueType)) then
      RaiseWriteError;
    BytesWrit := aStream.Write(aValue, sizeof(byte));
    if (BytesWrit <> sizeof(byte)) then
      RaiseWriteError;
  end
  {if the value is between 256 and 65535 write a word to the stream}
  else if (256 <= aValue) and (aValue < 64*1024) then begin
    ValueType := vaWord;
    BytesWrit := aStream.Write(ValueType, sizeof(ValueType));
    if (BytesWrit <> sizeof(ValueType)) then
      RaiseWriteError;
    BytesWrit := aStream.Write(aValue, sizeof(word));
    if (BytesWrit <> sizeof(word)) then
      RaiseWriteError;
  end
  {otherwise write a longint to the stream}
  else begin
    ValueType := vaLongint;
    BytesWrit := aStream.Write(ValueType, sizeof(ValueType));
    if (BytesWrit <> sizeof(ValueType)) then
      RaiseWriteError;
    BytesWrit := aStream.Write(aValue, sizeof(longint));
    if (BytesWrit <> sizeof(longint)) then
      RaiseWriteError;
  end;
end;
{--------}
procedure CalcCharDistribution(aStream : TStream;
                               aHTree  : PHuffmanTree);
{-calculate the character distribution from the data in the stream;
  fill the first 256 entries in the Huffman tree with the information}
var
  i         : integer;
  Buffer    : PByteArray;
  BytesRead : integer;
begin
  aStream.Position := 0;
  GetMem(Buffer, 1024);
  try
    BytesRead := aStream.Read(Buffer^, 1024);
    while (BytesRead <> 0) do begin
      for i := pred(BytesRead) downto 0 do
        inc(aHTree^[Buffer^[i]].hnCount);
      BytesRead := aStream.Read(Buffer^, 1024);
    end;
  finally
    FreeMem(Buffer, 1024);
  end;
end;
{--------}
procedure ConvertCodeStr(const aHCode  : THuffmanCodeStr;
                               aHCodes : PHuffmanCodes;
                               aNodeInx: integer);
{-convert a code string into binary; store in codes array}
var
  TempCode : THuffmanCode;
  ByteNum  : integer;
  BitNum   : byte;
  i        : integer;
begin
  {set the binary code to zeros, so we only have to record '1' bits}
  FillChar(TempCode, sizeof(TempCode), 0);
  {store the code length}
  TempCode.hcBitCount := length(aHCode);
  {fill the bits from the left in the binary code}
  ByteNum := 0;
  BitNum := 7;
  for i := 1 to length(aHCode) do begin
    if (aHCode[i] = '1') then
      TempCode.hcCode[ByteNum] :=
         TempCode.hcCode[ByteNum] or Bit[BitNum];
    if (BitNum = 0) then begin
      BitNum := 7;
      inc(ByteNum);
    end
    else
      dec(BitNum);
  end;
  {store binary code in the codes array}
  aHCodes^[aNodeInx] := TempCode;
end;
{--------}
procedure CalcHuffmanCodePrim(aNodeInx : integer;
                          var aHCode   : THuffmanCodeStr;
                              aHTree   : PHuffmanTree;
                              aHCodes  : PHuffmanCodes);
{-recursive routine to calculate all the Huffman codes for a given
  Huffman tree}
begin
  {if the current node is not a leaf, then visit the left subtree
   followed by the right subtree}
  if (aNodeInx >= 256) then begin
    {add a 0 bit on the end of the code string}
    inc(aHCode[0]);
    aHCode[length(aHCode)] := '0';
    {visit the left subtree}
    CalcHuffmanCodePrim(aHTree^[aNodeInx].hnLeftInx, aHCode, aHTree, aHCodes);
    {add a 1 bit on the end of the code string}
    aHCode[length(aHCode)] := '1';
    {visit the right subtree}
    CalcHuffmanCodePrim(aHTree^[aNodeInx].hnRightInx, aHCode, aHTree, aHCodes);
    dec(aHCode[0]);
  end
  {if the current node is a leaf, record the current code in the codes
   array}
  else begin
    ConvertCodeStr(aHCode, aHCodes, aNodeInx);
  end;
end;
{--------}
procedure CalcHuffmanCodes(aHTree  : PHuffmanTree;
                           aRoot   : integer;
                           aHCodes : PHuffmanCodes);
{-calculate the Huffman codes for a Huffman tree}
var
  HCode : THuffmanCodeStr;
begin
  {clear the codes array}
  FillChar(aHCodes^, sizeof(aHCodes^), 0);
  {to calculate the codes we have to visit every leaf and for each
   leaf we'll have accumulated a series of bits (going left from a
   parent node to a child node is a 0 bit, going right is a 1 bit);
   for the walk through the tree we'll use a modified inorder
   traversal (ie, visit the left subtree, there's no need to visit the
   node itself, visit the right subtree); because we know the tree has
   a maximum depth of 255, we'll use recursion without getting too
   worried about blowing the stack}
  HCode := '';
  CalcHuffmanCodePrim(aRoot, HCode, aHTree, aHCodes);
end;
{--------}
procedure ReadCharDistribution(aStream : TStream;
                               aHTree  : PHuffmanTree);
{-read a character distribution from a stream}
var
  i         : integer;
  CharCount : integer;
  Ch        : char;
begin
  {the first byte in the stream is the number of characters with non-
   zero counts}
  aStream.Position := 0;
  CharCount := ord(ReadChar(aStream));
  {read the characters and their counts}
  for i := 0 to pred(CharCount) do begin
    Ch := ReadChar(aStream);
    aHTree^[ord(Ch)].hnCount := ReadValue(aStream);
  end;
end;
{--------}
procedure WriteCharDistribution(aStream : TStream;
                                aHTree  : PHuffmanTree);
{-write a character distribution to a stream}
var
  i         : integer;
  CharCount : byte;
begin
  {position the output stream}
  aStream.Position := 0;
  {the first byte in the stream is the number of characters with non-
   zero counts; calculate this and output the answer}
  CharCount := 0;
  for i := 0 to 255 do
    if (aHTree^[i].hnCount <> 0) then
      inc(CharCount);
  WriteChar(aStream, char(CharCount));
  {now output those chars and their counts}
  for i := 0 to 255 do
    with aHTree^[i] do begin
      if (hnCount <> 0) then begin
        WriteChar(aStream, char(i));
        WriteValue(aStream, hnCount);
      end;
    end;
end;
{--------}
procedure BuildHuffmanTree(aHTree         : PHuffmanTree;
                       var aLastParentInx : integer);
{-given a Huffman tree just containing the character distributions,
  build the entire tree; return the index of the root}
var
  i  : integer;
  PQ : THuffmanPriorityQueue;
  Node1Inx  : longint;
  Node2Inx  : longint;
  ParentInx : integer;
begin
  ParentInx := aLastParentInx;
  {create a priority queue}
  PQ := THuffmanPriorityQueue.Create(aHTree);
  try
    {add all the non-zero nodes to the queue}
    for i := 0 to 255 do
      if (aHTree^[i].hnCount <> 0) then
        PQ.Add(i);
    {SPECIAL CASE: there is only one non-zero node, ie the input
     stream consisted of just one character, repeated one or more
     times; set the parent index to the single character}
    if (PQ.Count = 1) then
      ParentInx := PQ.Remove
    {otherwise we have the normal, many different chars, case}
    else
      {while there is more than one item in the queue, remove the two
       smallest, join them to a new parent, and add the parent to the
       queue}
      while (PQ.Count > 1) do begin
        Node1Inx := PQ.Remove;
        Node2Inx := PQ.Remove;
        inc(ParentInx);
        with aHTree^[ParentInx] do begin
          hnLeftInx := Node1Inx;
          hnRightInx := Node2Inx;
          hnCount := aHTree^[Node1Inx].hnCount +
                     aHTree^[Node2Inx].hnCount;
        end;
        PQ.Add(ParentInx);
      end;
  finally
    PQ.Free;
  end;
  aLastParentInx := ParentInx;
end;
{--------}
procedure DoHuffmanCompression(aInStream  : TStream;
                               aOutStream : TStream;
                               aHCodes    : PHuffmanCodes);
{-given an array of Huffman codes, compress the input stream to the
  output stream}
var
  B : byte;
  CollectorByte : byte;
  BitCount      : integer;
  i             : integer;
begin
  {reset the input stream to the start}
  aInStream.Position := 0;
  {for each character in the input stream, write its Huffman code to
   the output stream}
  CollectorByte := 0;
  BitCount := 0;
  for i := 0 to pred(aInStream.Size) do begin
    aInStream.Read(B, sizeof(B));
    WriteBits(aHCodes^[B], aOutStream, CollectorByte, BitCount);
  end;
  {if we've some bits left over write them out as well}
  if (BitCount <> 0) then begin
    {shift the bits to the top of the byte}
    CollectorByte := CollectorByte shl (8 - BitCount);
    aOutStream.Write(CollectorByte, 1);
  end;
end;
{--------}
procedure DoHuffmanDecompression(aInStream  : TStream;
                                 aOutStream : TStream;
                                 aHTree     : PHuffmanTree;
                                 aRoot      : integer);
{-given a Huffman tree, decompress the input stream to the output
  stream}
var
  CharCount      : longint;
  TotalCharCount : longint;
  BitNum         : integer;
  CollectorByte  : byte;
  CurrNode       : integer;
  GoLeft         : boolean;
  Ch             : char;
begin
  {calculate the total number of characters to decompress; preset the
   loop variables}
  TotalCharCount := aHTree^[aRoot].hnCount;
  CharCount := 0;
  BitNum := 0;
  CurrNode := aRoot;
  {repeat until all the characters have been decompressed}
  while CharCount < TotalCharCount do begin
    {read the next bit}
    if (BitNum = 0) then begin
      aInStream.Read(CollectorByte, sizeof(CollectorByte));
      BitNum := 7;
    end
    else
      dec(BitNum);
    GoLeft := (CollectorByte and Bit[BitNum]) = 0;
    {walk down the Huffman tree}
    if GoLeft then
      CurrNode := aHTree^[CurrNode].hnLeftInx
    else
      CurrNode := aHTree^[CurrNode].hnRightInx;
    {if we have reached a leaf, output the character concerned, and
     reset the current node to the root}
    if (CurrNode < 256) then begin
      Ch := char(CurrNode);
      aOutStream.Write(Ch, sizeof(byte));
      CurrNode := aRoot;
      inc(CharCount);
    end;
  end;
end;
{--------}
procedure WriteMultipleChars(aStream : TStream;
                             aCh     : char;
                             aCount  : longint);
{-write several copies of a character to a stream}
const
  BufferSize = 1024;
var
  Buffer       : PByteArray;
  BytesToWrite : integer;
  BytesWrit    : integer;
begin
  GetMem(Buffer, BufferSize);
  try
    FillChar(Buffer^, BufferSize, aCh);
    while (aCount > 0) do begin
      if (aCount < BufferSize) then
        BytesToWrite := aCount
      else
        BytesToWrite := BufferSize;
      BytesWrit := aStream.Write(Buffer^, BytesToWrite);
      dec(aCount, BytesWrit);
    end;
  finally
    FreeMem(Buffer, BufferSize);
  end;
end;
{====================================================================}


{===Interfaced routines==============================================}
procedure HuffmanCompress(aInStream, aOutStream : TStream);
var
  HTree  : PHuffmanTree;
  Root   : integer;
  HCodes : PHuffmanCodes;
begin
  {if there's nothing to compress, exit now}
  if (aInStream.Size = 0) then
    Exit;
  {allocate the Huffman tree}
  New(HTree);
  try
    {initialise the tree}
    FillChar(HTree^, sizeof(HTree^), 0);
    {get the distribution of characters in the input stream, place in
     the first 256 elements of the Huffman tree}
    CalcCharDistribution(aInStream, HTree);
    {build the Huffman tree}
    Root := 255;
    BuildHuffmanTree(HTree, Root);
    {when this point is reached we know the Huffman tree is rooted at
     Root; if Root is a leaf, then the input stream just consisted of
     repetitions of one character, so output the minimal compressed
     data, essentially RLE compression}
    if (Root < 256) then
      WriteCharDistribution(aOutStream, HTree)
    else {Root is not a leaf} begin
      {allocate the codes array}
      New(HCodes);
      try
        {calculate all the codes}
        CalcHuffmanCodes(HTree, Root, HCodes);
        {we are now ready to compress the input stream, however we
         must first output some information to the output stream to
         aid the decompressor}
        WriteCharDistribution(aOutStream, HTree);
        {compress the characters in the input stream}
        DoHuffmanCompression(aInStream, aOutStream, HCodes);
      finally
        Dispose(HCodes);
      end;
    end;
  finally
    Dispose(HTree);
  end;
end;
{--------}
procedure HuffmanDecompress(aInStream, aOutStream : TStream);
var
  HTree : PHuffmanTree;
  Root  : integer;
begin
  {if there's nothing to decompress, exit now}
  if (aInStream.Size = 0) then
    Exit;
  {allocate the Huffman tree}
  New(HTree);
  try
    {initialise the tree}
    FillChar(HTree^, sizeof(HTree^), 0);
    {read the distribution of characters from the input stream, place
     in the appropriate elements of the Huffman tree}
    ReadCharDistribution(aInStream, HTree);
    {build the Huffman tree}
    Root := 255;
    BuildHuffmanTree(HTree, Root);
    {when this point is reached we know the Huffman tree is rooted at
     Root; if Root is a leaf, then the original stream just consisted
     of repetitions of one character}
    if (Root < 256) then
      WriteMultipleChars(aOutStream, char(Root), HTree^[Root].hnCount)
    {otherwise, using the Huffman tree, decompress the characters in
     the input stream; note that the number of chars to decompress
     is the count at the root of the Huffman tree}
    else
      DoHuffmanDecompression(aInStream, aOutStream, HTree, Root);
  finally
    Dispose(HTree);
  end;
end;
{====================================================================}

end.